home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
FLEXFILE.ARJ
/
FLEXINFO.EXE
/
VCONVERT.PRG
< prev
Wrap
Text File
|
1991-10-21
|
7KB
|
241 lines
*:*********************************************************************
*:
*: Program: VCONVERT.PRG
*:
*: System: Flexfile Conversion Program
*: Author: Don Caton
*: Copyright:
*: Last modified: 10/23/90 2:28
*:
*: Procs & Fncts: MAIN()
*:
*: Documented 10/23/90 at 02:32 SNAP! version 4.02
*:*********************************************************************
/*
*
* Compile with /m /n /w /a
*
*/
#include "inkey.ch"
#include "directry.ch"
#include "dbstruct.ch"
#include "box.ch"
#include "setcurs.ch"
#include "set.ch"
#command BEEP => OutErr( Chr(7) )
#translate fname_base( <filename> ) => ;
Trim( IIF( At (".", <filename> ) == 0, <filename>, ;
Substr( <filename>, 1, At( ".", <filename> ) - 1 ) ) )
#translate fname_ext( <filename> ) => ;
Trim( Substr( <filename>, At( ".", <filename> ) + 1 ) )
#define CHECKMARK "√"
MEMVAR getlist
FUNCTION main
LOCAL filename := SPACE(40),; // get field
sourcename,; // filename to convert
basename,; // filename to convert with extension stripped off
src_struct,; // structure of source file
des_struct,; // structure of destination file
before,; // file sizes of dbf/dbt files before conversion
after,; // file sizes of dbf/dbv files after conversion
count,; // progress counter
errorobj // error object created on error
Set( _SET_SCOREBOARD, .F. )
Set( _SET_CURSOR, SC_NONE )
DO WHILE .T.
SetColor( "bg+/b,gr+/n,b")
CLS
@ 0,0,23,79 BOX B_DOUBLE_SINGLE
@ 2,1 TO 2,79
@ 2,0 SAY "├"
@ 2,79 SAY "┤"
SetColor( "gr+/b")
@ 1,18 SAY "Flexfile .dbt to .dbv File Conversion Utility"
SetColor( "w+/b" )
keyline( 24, "Esc-Quit", {"Esc"} )
@ 4,4 SAY "Enter name of file to convert:" GET filename PICTURE "@K!" ;
VALID ! EMPTY( filename )
Set( _SET_CURSOR, SC_NORMAL )
Set( _SET_INSERT, .F. )
SetKey( 22,;
{|| SetCursor( IIF( ReadInsert( ! ReadInsert() ), SC_NORMAL, SC_INSERT ) ) } )
READ
SetKey( 22, NIL )
Set( _SET_CURSOR, SC_NONE )
IF LASTKEY() == K_ESC
Setcolor( "w/n,w/n,n" )
CLS
Set( _SET_CURSOR, SC_NORMAL )
QUIT
ENDIF
sourcename := Alltrim( filename )
basename := fname_base( filename )
IF sourcename == basename
sourcename += ".DBF"
ENDIF
IF ! File( sourcename )
@ 6,4 SAY "File: " + sourcename + " not found"
BEEP
pressakey()
ELSE
USE (sourcename) NEW ALIAS source
src_struct = DbStruct()
IF Ascan( src_struct, { |field| field[DBS_TYPE] == "M" } ) == 0
USE
@ 6,4 SAY "Nothing to convert"
@ 8,4 SAY sourcename + " does not contain any memo fields"
BEEP
pressakey()
ELSE
keyline( 24, "Please wait a moment..." )
@ 6,4 SAY "Creating new dbf file..."
* ..... copy structure of source file
des_struct = Aclone( src_struct )
* ..... convert memo fields to character for dbv pointer
AEval( des_struct, { |field| ;
IIF( field[DBS_TYPE] == "M", field[DBS_LEN] := 6, NIL ) , ;
IIF( field[DBS_TYPE] == "M", field[DBS_TYPE] := "C", NIL ) } )
* ..... create new dbf file with converted field types
DbCreate( basename + ".new", des_struct )
USE ( basename + ".new" ) ALIAS dest NEW
QQout( CHECKMARK )
@ 8,4 SAY "Creating new dbv file..."
IF File( basename + ".dbv")
Ferase( basename + ".dbv" )
ENDIF
IF V_Use( basename ) == -1
errorobj := ErrorNew()
errorobj:description := "Open Error"
errorobj:operation := "V_USE()"
errorobj:filename := basename + ".dbv"
errorobj:subsystem := "Flexfile"
errorobj:subcode := V_Error()
Eval( ErrorBlock(), errorobj )
ENDIF
* ..... copy records to new dbf/dbv files
SELECT source
count := 0
QQout( CHECKMARK )
@ 10,4 SAY "Copying records - "
DbEval( {|| DevPos( 10, 22 ), ;
QQOut( Transform( ( ++count / Reccount() ) * 100, "999 % complete" ) ), ;
copyrec( src_struct ) } )
CLOSE DATABASES
V_Close( "tempfile.dbv" )
before := filesize( basename + ".dbf" ) + filesize( basename + ".dbt" )
after := filesize( basename + ".new" ) + filesize( basename + ".dbv" )
@ 12,4 SAY "Renaming " + IIF( At( ".", sourcename ) == 0, ;
basename + ".DBF" , sourcename ) + " to " + basename + ".BAK..."
IF FRename( sourcename, basename + ".bak" ) == -1
BEEP
@ 14,4 SAY "DOS error " + ntoc( Ferror() ) + " renaming file"
pressakey()
ELSE
FRename( basename + ".new", sourcename )
@ 14,4 SAY "Conversion complete."
@ 16,4 SAY "Filesize using memo fields: " + ntoc( before )
@ 17,4 SAY "Filesize using flexfile: " + ntoc( after )
@ 19,4 SAY "You've saved " + ntoc( before - after ) + " bytes (" + ;
ntoc( ( ( before - after ) / before ) * 100 ) + "%)"
pressakey()
ENDIF
ENDIF
ENDIF
ENDDO
STATIC FUNCTION copyrec( struct )
LOCAL x, numfields := Fcount(), errorobj
SELECT dest
APPEND BLANK
FOR x := 1 TO numfields
IF struct[x][DBS_TYPE] == "M" .AND. ! EMPTY( source->( FieldGet( x ) ) )
FieldPut( x, V_Replace( source->( FieldGet( x ) ), ' ' ) )
IF V_Error() # 0
errorobj := ErrorNew()
errorobj:description := "Write Error"
errorobj:operation := "V_REPLACE()"
errorobj:filename := V_Filename()
errorobj:subsystem := "Flexfile"
errorobj:subcode := V_Error()
Eval( ErrorBlock(), errorobj )
ENDIF
ELSE
FieldPut( x, source->( FieldGet( x ) ) )
ENDIF
NEXT
SELECT source
RETURN NIL
STATIC FUNCTION filesize( filename )
LOCAL bytes := 0
AEval( Directory( filename ), { |file| bytes += file[F_SIZE] } )
RETURN bytes
STATIC FUNCTION keyline( line, txt, keys )
LOCAL start_col := ( 80 - Len( txt ) ) / 2,;
savecolor := SetColor( IIF( IsColor(), "w+/b", "w+/n" ) )
@ line,0 CLEAR TO line,79
@ line,start_col-- SAY txt
SETCOLOR( "n/w" )
AEVAL( keys, {|x| DevPos( line, AT( x, txt ) + start_col ), DevOut( x ) } )
SETCOLOR( savecolor )
RETURN NIL
STATIC FUNCTION pressakey
LOCAL savecolor := SetColor( "gr*+/b" )
@ MaxRow(), 0 CLEAR
@ MaxRow(), 33 SAY "Press any key..."
CLEAR TYPEAHEAD
Inkey(0)
SetColor( savecolor )
RETURN NIL
STATIC FUNCTION ntoc( numeric )
LOCAL ret_val := STR( numeric ), pict
pict := IIF( At( ".", ret_val ) == 0, "999,999,999", "999,999,999.99999" )
RETURN AllTrim( Transform( numeric, pict ) )
*: EOF: VCONVERT.PRG